Attribute VB_Name = "modBrowseFolder"
Option Explicit
Option Compare Text

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modBrowseFolder
' By Chip Pearson, chip@cpearson.com , www.cpearson.com
'
' This module supports two functions that prompt the user for a folder name using
' a Browse For Folder dialog. The API version of the function (BrowseFolderAPI)
' uses Windows API functions and thus needs no other references. The second version
' of the function (BrowseFolderSHELL) uses the "Microsoft Shell Controls And
' Automation" library and needs a reference to that library (in VBA Editor, Tools
' menu, References, scroll down to and check the library name). Both functions take
' one optional parameter (type String) to specify the caption of the dialog and
' return a String value containing the full name of the selected folder. If the
' user cancel's the dialog, the result is vbNullString.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260

Type BrowseInfo
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszINSTRUCTIONS As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Type SHFILEOPSTRUCT
    hwnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAnyOperationsAborted As Boolean
    hNameMappings As Long
    lpszProgressTitle As String
End Type

Declare Function SHGetPathFromIDListA Lib "shell32.dll" ( _
    ByVal pidl As Long, _
    ByVal pszBuffer As String) As Long

Declare Function SHBrowseForFolderA Lib "shell32.dll" ( _
    lpBrowseInfo As BrowseInfo) As Long


Function BrowseFolderAPI(Optional Caption As String = "") As String

Dim BrowseInfo As BrowseInfo
Dim FolderName As String
Dim ID As Long
Dim Res As Long

With BrowseInfo
   .hOwner = 0
   .pidlRoot = 0
   .pszDisplayName = String$(MAX_PATH, vbNullChar)
   .lpszINSTRUCTIONS = Caption
   .ulFlags = BIF_RETURNONLYFSDIRS
   .lpfn = 0
End With

FolderName = String$(MAX_PATH, vbNullChar)
ID = SHBrowseForFolderA(BrowseInfo)
If ID Then
   Res = SHGetPathFromIDListA(ID, FolderName)
   If Res Then
       BrowseFolderAPI = Left$(FolderName, InStr(FolderName, vbNullChar) - 1)
   End If
End If

End Function


Function BrowseFolderSHELL(Optional Caption As String, _
    Optional InitialFolder As String) As String
Const BIF_RETURNONLYFSDIRS As Long = &H1
Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Const BIF_RETURNFSANCESTORS As Long = &H8
Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Const BIF_BROWSEFORPRINTER As Long = &H2000
Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Const MAX_PATH As Long = 260
Dim SH As Shell32.Shell
Dim F As Shell32.Folder

Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
If Not F Is Nothing Then
    BrowseFolderSHELL = F.Items.Item.Path
End If

End Function



